COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Only the semantics of this macro definitions package are given,
C00009 00003	(DECLARE (SPECIAL SAVE-MACROS %%CLOBBER-MACROS%% QQQ COMPILE-MACROS))
C00016 00004
C00018 ENDMK
C⊗;
;;; Only the semantics of this macro definitions package are given,
;;; and not the implementation details. This is a Maclisp system file.

;;;
;;; This  file contains some fancy macro definition hacks.
;;; %%EXPAND%% and MACRODEF are due to Guy Steele at MIT. Simply
;;; stated one can say (MACRODEF PUSH (FROB PDL)(SETQ PDL (CONS FROB PDL)))
;;; or (MACRODEF PROG1 X (PROG2 NIL .X))
;;; If the formal parameter is not enclosed in parentheses, it is bound to
;;; CDR of the form which is to be macro-expanded. To understand how the above
;;; work, think of SUBSTituting for the formal parameters.
;;; The macro MACRO allows one a bit more freedom in argument decomposition
;;; and code production. The expense is that the very hairy Edit matcher
;;; is used to effect binding. As an exception to the usual rule for
;;; match variables is that they are really lambda-bound during the macro
;;; definition process. Thus the macro definition facility has no unexpected
;;; side effects. 
;;; Here is an example of how to use the MACRO facitily:
;;;	(MATCH-MACRO FOO ((?A ?B)(?C ?D))(COND ((AND (SYSP ?A)
;;;					       (SYSP ?B))
;;;					  (CODE (PROGN (?A ?C) (?B ?D))))
;;;					 (T (CODE '(?A ?B ?C ?D)))))
;;;
;;; Then:
;;;	(DEFUN BAR NIL (FOO (ADD1 SUB1)(2 5)))
;;; When evaluated will return 4. And, the definition of BAR will be changed to:
;;;  	(DEFUN BAR NIL (PROGN (ADD1 2)(SUB1 5)))
;;;
;;; CODE simply takes an s-expression, and replaces occurrences of ? and *
;;; variables by their current bindings; variables like →?X are replaced by ?X;
;;; s-expressions preceeded by "," are EVALuated.
;;; Thus one can do things like:
;;;	(MACRO FOO (?A ?B)(COND ((NUMBERP ?B)(CODE (,(COND ((SYSP ?A) (CODE ?A))
;;;							   (T (CODE ADD1))) ?B)
;;;				(T (CODE (ERROR FOO '(?A ?B) 9.)))))
;;;
;;;
;;; One of the advantages of the macro definition facilities here is that 
;;; as well as the macros being expanded by the compiler, they are expanded
;;; during interpretation as well. This is controlled by the switch *RSET
;;; which is set to T by saying (*RSET T). Inn addition this switch instructs
;;; the interpreter to put debugging information onto the control stack. Typically
;;; when one is debugging, one does not care too much about macros not being
;;; destructively expanded. A further degree of freedom is the SAVE-MACROS
;;; switch, which causes macro expansions to be saved; (UNCAN) restores all
;;; code to unexpanded form.

(DECLARE (MACROS T) (MAPEX T) (SPECIAL %%CLOBBER-MACROS%%))
(DECLARE (*LEXPR %MATCH))

;(DECLARE (*EXPR %CHAR1)) 

(OR (BOUNDP '%%CLOBBER-MACROS%%)
    (SETQ %%CLOBBER-MACROS%% NIL))

(MACRODEF %CHAR1 (ATOM) 
       ;; returns the 1st character of an atom.
       (COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))

   
(DEFUN MACROBIND (X ARGS ACTION)
 ((LAMBDA (VARS)
   (PROGV VARS
        (MAPCAR (FUNCTION (LAMBDA (Q) NIL)) VARS)
    (%%%EXPAND1%%% ARGS X ACTION)))
  (MATCHVARS ARGS))) 

(DEFUN %%%EXPAND1%%% (ARGS FORM ACTION)
 (COND ((%MATCH ARGS (CDR FORM))
     ((LAMBDA (Q) (COND ((AND
			  *RSET 
			  (COND ((BOUNDP '%%CLOBBER-MACROS%%)
				 (NOT %%CLOBBER-MACROS%%))
				(T))) 
			 Q)
			((ATOM Q)
			 Q)
			(T (RPLACA FORM (CAR Q))
			   (RPLACD FORM (CDR Q)))))
      (EVAL ACTION)))
    (T (ERROR '|Non-conformal mapping|
	      (LIST ARGS
		    (CDR FORM))
	      9.)))))))


;(DEFUN MACROBIND MACRO (X) 
;       ((LAMBDA (A) (RPLACA X (CAR A)) (RPLACD X (CDR A)))
;		 (LIST 'PROG (MATCHVARS (CADR X))(LIST 'RETURN (CADDR X)))))

(DECLARE (SPECIAL MMM)) 

(DEFUN MATCHVARS (X) (PROG (MMM) (MMATCHVARS X) (RETURN MMM))) 

(DEFUN MMATCHVARS (X) 
       (COND ((ATOM X)
	      (COND ((MEMQ X '(? *)))
		    ((MEMQ (%CHAR1 X) '(? *))
		     (OR (MEMQ X MMM) (SETQ MMM (CONS X MMM))))))
		    ((OR (ATOM X) (MEMQ (CAR X) '($R RESTRICT)))
		      (COND ((MEMQ (CADR X) '(? *)))
			    (T (CADR X))))
	     (T (MMATCHVARS (CAR X)) (MMATCHVARS (CDR X))))) 
(DECLARE (SPECIAL SAVE-MACROS %%CLOBBER-MACROS%% QQQ COMPILE-MACROS))

(OR (BOUNDP 'SAVE-MACROS)
    (SETQ SAVE-MACROS NIL))

(OR (BOUNDP 'COMPILE-MACROS)
    (SETQ COMPILE-MACROS NIL))

;;; %%clobber-macros%% tells whether to ignore *rset

(DEFUN %%EXPAND%% (EXP ALIST FORM)
 (AND SAVE-MACROS (PUTPROP 'EXPANDED-MACROS 
      			   (CONS (CONS EXP (SUBST NIL NIL EXP)) 
            			 (GET 'EXPANDED-MACROS 'TRANSLATIONS))
			   'TRANSLATIONS))
 ((LAMBDA (WWW) (COND ((AND
			*RSET (COND ((BOUNDP '%%CLOBBER-MACROS%%)
				     (NOT %%CLOBBER-MACROS%%))
				    (T))) WWW)
		      ((ATOM WWW)
		       WWW)
			     (T (PROG2 (RPLACA EXP (CAR WWW))
				       (RPLACD EXP (CDR WWW))))))
	 (SUBLIS (MAPCAR (FUNCTION (LAMBDA (HHH) 
					   (CONS (CAR HHH)
						 (EVAL (CADR HHH)))))
			 ALIST)
		 FORM)))  

(DEFUN UNCAN ()(MAPC (FUNCTION (LAMBDA(X)(RPLACA (CAR X) (CADR X))
					 (RPLACD (CAR X) (CDDR X))))
		     (GET 'EXPANDED-MACROS 'TRANSLATIONS))
		(DEFPROP EXPANDED-MACROS NIL TRANSLATIONS)
		T)

(declare (special x))
(DEFUN (MACRODEF MACRO) (QQQ) 
       (CONS 'DEFUN
	     (append
	      (cond ((atom (cadr qqq))
		     (list (cadr qqq) 'macro))
		    (t 
		     (cond ((not compile-macros)
			    (list (caadr qqq) 'macro))
			   ((= (length (cadr qqq)) 1)
			    (ncons (list (caadr qqq) 'macro)))
			   (t (ncons (cadr qqq))))))
	      (list
	     '(X)
	     (LIST '%%EXPAND%%
		   'X
		   (LIST 'QUOTE
		   (DO ((RRR (CADDR QQQ) (CDR RRR))
			(CCC '(CDR X) (LIST 'CDR CCC))
			(LLL NIL
			     (CONS (LIST (CAR RRR)
					 (LIST 'CAR CCC))
				   LLL)))
		       ((ATOM RRR)
			(AND RRR (SETQ LLL (CONS (LIST RRR CCC) LLL)))
			(NREVERSE LLL))))
		   (LIST 'QUOTE
		   (cond ((= (length qqq) 4)(CADDDR QQQ))
			 (t (rplacd (cddr qqq) (ncons (cons 'progn (cdddr qqq))))
			    (CADDDR QQQ)))))))))


(DEFUN (TRANSDEF MACRO) (QQQ) 
       (CONS 'DEFUN
	     (append
	      (cond ((atom (cadr qqq))
		     (ncons (list (cadr qqq) 'trans)))
		    (t 
		     (cond ((not compile-macros)
			    (ncons (list (caadr qqq) 'trans)))
		      ((= (length (cadr qqq)) 1)
			    (ncons (list (caadr qqq) 'trans)))
			   (t (ncons (cadr qqq))))))
	      (list
	     '(X)
	     (LIST '%%EXPAND%%
		   'X
		   (LIST 'QUOTE
		   (DO ((RRR (CADDR QQQ) (CDR RRR))
			(CCC '(CDR X) (LIST 'CDR CCC))
			(LLL NIL
			     (CONS (LIST (CAR RRR)
					 (LIST 'CAR CCC))
				   LLL)))
		       ((ATOM RRR)
			(AND RRR (SETQ LLL (CONS (LIST RRR CCC) LLL)))
			(NREVERSE LLL))))
		   (LIST 'QUOTE
		   (cond ((= (length qqq) 4)(CADDDR QQQ))
			 (t (rplacd (cddr qqq) (ncons (cons 'progn (cdddr qqq))))
			    (CADDDR QQQ)))))))))

;(MACRODEF TRANS
;	  (NAME ARGS  ACTION)
;	  (DEFUN (NAME TRANS)
;		 (X)
;		 (MACROBIND X 'ARGS 'ACTION)))    

(defun (trans macro) (x)
       (list 'defun  
	     (list (cAdr x) 'trans) (list 'x)
	     (list 'macrobind 'x 
		   (list 'quote (caddr x))
		   (list 'quote 
			 ((lambda (q)(cond ((= (length q) 1) (car q))
					   (t (cons 'progn q))))
			  (cdddr x)))))    )

(defun (match-macro macro) (x)
       (cons 'defun  
	     (append
	      (cond ((atom (cadr x))
		     (list (cadr x) 'macro))
		    (t 
		     (cond ((not compile-macros)
			    (list (caadr x) 'macro))
		      ((= (length (cadr x)) 1)
			    (jcons (list (caadr x) 'MACRO)))
			   (pλ@Q9G←]fQGCIHApRR$RRR~(∩@@@@@QY%ch~∀$@@@@@@QY%gh@O`RQYSMh@O[¬Ge←E%]H@O`@~∀∩$∩@@@@@QY%ch@OEk←iJQGCI⊃dApR$~∀∩∩$@@@@@QYSMh@OcU←iJ@4∀∩∩∩$@@@@ QYC[	IB@QDRQG←9H@PPt@QYK9OiPADR@bRQGCd↓bRR~(∩∩∩∩$∩@@@@@QhQG←]L@Oae=O\Ab$RRR~(∩∩∩∩@@@@!GIIIHApBR$RR@@@RRR4∀~∀v!≠βπ¬=	βA5βπ%≡4∀v∩@Q≥β≠∀Aβ%∂LAβπ)%≠≤R~(v∩@@!	
+8@Q≥β5
Aβ
%≡R~(r∩α@!0R~∀l∩∩@Q5βπ%∨	∪≥λA`@Oβ%≥&@Oβ
)∪∨≤$RR~∀4∀Q	→+≤Aπ=	αA
∃1!$@!0R@P∀K∪≥'Qβ≥)∪¬)
@Q
β$A0$RR@~(~∀Q	∃
!%∨@@K≠βQβ⊂@Q5β)π⊂↓
β&A⊃'⊗@Q5βεA→M RRA¬+)∨→=βλR@4∀~∀v!	
!I≠ @K
⊃β$bQ≠β)
⊂A
βLA	'⊗Q≠βε↓→' R$Aβ+)=→∨βλ$@~∀~(vQ'Q'3≥)¬0@hh8~∀f∩@@O≠¬π%≡~(v∩@@NQ→β5¬	αA9∪_@Q1∪'(@≤BC4
1¬¬αBJ⊗ε"I%%%h(4)D"⊗∞∩
∩∃↓"≥α⊗∞εa↓}∞*↓∃ :88RJJ↓Q `h%λD,5Ydα*,→j5$jI∀
$T¬¬∧
E∀hR∧∧ααα∧¬∧≤|hDαBD~Itj¬λ~BHh!∀ααα∧∧αD≤yhBαBλZ∩¬∧~Dα;|8U∩αE:X%≥"	i∀b∧i→Bα*t84*J⊃Q HJ∧∧ααBλZ∩¬∧~Dα;z∀∧rm
XZ5$LyaTl
)5RHh!⊃∩αα∧¬αD-∀
∧
"∧u"JαuZ5$
%U⊂hP⊃∀ααᬬ∧l,Z∀¬∧
D∧rCz¬%∩J¬λ~BHh!⊃∩αα∧¬αD-∀¬α,≤λ~#
¬λ~BJαs∃∩¬∧~E⊂hP⊃∀ααᬬ∧l,Z∀αB,9λ∃∪
λλ∃"J∧uαRβu∃⊂hP⊃∀ααα∧¬¬≥,*:B∧t→D∧tLD¬¬≥LXZdb
λ∃"J∃⊃PPH∀∧ααα
λ∃"J∃⊃PPJ∧∧ααα¬λU
αλ8∃∩¬λ~BJαt∀∀-4→D∩
J¬λU4D¬∧≤J$¬∧
E∃∩Hh!∀ααα∧¬αDlYZ∩αD8~"¬∧~E∩α:πtαRJ∀¬∧≤|j4αD≤~$¬∧
E⊃PPH⊃⊃⊂Jα∧∧αB*Y→e≥$→jDL
HTαD≤J$¬∧
E∃∩JHQ!∩αα∧∧αBDZ∀αB,9λ∃∪
¬λ4
∩
λ∃"J∀∧rRHQ!∩αα∧∧ααD~
∧,tD¬∧-4→DαD≤~$¬∧
E∃∩αBTY∀u≥H→e$L~HRαD8J"¬∧~E∩JJ⊃Q Jα∧∧ααB	XTm
¬λ4
∩
λ∃"J∧u¬∀-:J$L≥D	∃∀-:J$L≥D∧E∩αI~"↓5$αdM∩∃⊃PPJ∧∧ααα¬∧R,Lj:DuI_∃$*¬λ4%$
∧
"∃∃⊂hP∀∧ααα¬
BαD9ye~α∧TTLU:H∀u$_~D*αλ8∃∩¬λ~BJHQ!⊂Jα∧∧ααα∧TTLU:H∀u$_~D*αλ8E∩¬λ~BJJ∃∃∩JQ